(GLOBAL (FUNCTION MATCH))

(DECLARE (SPECIAL MALIST MALIST1 MALIST2 MALISTV1 MALISTV2 NOBIND) (*FEXPR CERR))

(DEFPROP MATCH
	 (LAMBDA N
	  ((LAMBDA(VARPAT DATAPAT)
	    (PROG (MALIST1 MALIST2 MALISTV1 MALISTV2 NOBIND)
		  (COND ((> N 2) (SETQ MALIST1 (ARG 3) MALIST2 (ARG 4) NOBIND T)))
		  (SETQ MALISTV1
			(GET (QUOTE MALIST1) (QUOTE VALUE))
 			MALISTV2
			(GET (QUOTE MALIST2) (QUOTE VALUE)))
		  (RETURN (COND ((MATCH1 VARPAT DATAPAT) (LIST MALIST1 MALIST2))))))
	   (ARG 1)
	   (ARG 2)))
 	 EXPR)

(DECLARE (UNSPECIAL MALIST1 MALIST2))

(DEFPROP MATCH1
	 (LAMBDA(VARPAT DATAPAT)
	  (PROG (ACTOR1 ACTOR2)
		(RETURN
		 (COND ((ATOM VARPAT) (MATCH2 DATAPAT VARPAT MALISTV2))
		       ((ATOM DATAPAT) (MATCH2 VARPAT DATAPAT MALISTV1))
		       ((EQ (SETQ ACTOR2 (CAR DATAPAT)) (QUOTE !@)))
		       ((MEMQ ACTOR2 (QUOTE (!! !?)))
			(MATCH2 VARPAT (ACTORSUBST DATAPAT (CDR MALISTV2)) MALISTV1))
		       ((EQ (SETQ ACTOR1 (CAR VARPAT)) (QUOTE !))
			(MUSTBIND (CDR VARPAT) DATAPAT MALISTV1 MALISTV2))
		       ((EQ ACTOR1 (QUOTE !?)) (TRYBIND (CDR VARPAT) DATAPAT MALISTV1 MALISTV2 T))
		       ((EQ ACTOR1 (QUOTE !@)) (MBINDR (CADR VARPAT) (CDDR VARPAT) DATAPAT MALISTV1))
		       ((EQ ACTOR1 (QUOTE !!)) (MUSTNOTASSIGN (CADR VARPAT) DATAPAT MALISTV1 MALISTV2))
		       ((EQ ACTOR1 (QUOTE !/,)) (COMMA (CDR VARPAT) DATAPAT MALISTV1 MALISTV2))
		       ((EQ ACTOR2 (QUOTE !)) (TRYBIND (CDR DATAPAT) VARPAT MALISTV2 MALISTV1 NIL))
		       ((EQ ACTOR2 (QUOTE !@)))
		       ((EQ ACTOR2 (QUOTE !/,)) (COMMA (CDR DATAPAT) VARPAT MALISTV2 MALISTV1))
		       ((MATCH1 (CAR VARPAT) (CAR DATAPAT)) (MATCH1 (CDR VARPAT) (CDR DATAPAT)))))))
 	 EXPR)

(DECLARE (UNSPECIAL MALISTV2))

(DEFPROP COMMA
	 (LAMBDA(VARSPEC DATAPAT MV1 MV2)
	  ((LAMBDA(VAR VALSPEC)
	    (COND
	     (VALSPEC
	      ((LAMBDA (VAL) (COND ((MATCH2 DATAPAT VAL MV2) (MBINDV VAR VAL MV1))))
	       ((LAMBDA (MALIST) (EVAL (CAR VALSPEC))) (CDR MV1))))
	     (((LAMBDA(VAL)
		(COND ((EQ VAL (QUOTE *UNASSIGNED)) (TRYASSIGN VAR DATAPAT (CDR MV1) MV2 (EQ MV1 MALISTV1)))
		      ((MATCH2 DATAPAT VAL MV2))))
	       ((LAMBDA (MALIST) (!/,1 VAR)) (CDR MV1))))))
	   (CAR VARSPEC)
	   (CDR VARSPEC)))
 	 EXPR)

(DECLARE (UNSPECIAL MALISTV1))

(DEFPROP MATCH2
	 (LAMBDA(VARPAT EXP MV)
	  (COND ((ATOM VARPAT) (EQUAL VARPAT EXP))
		(((LAMBDA(ACTOR)
		   (COND ((MEMQ ACTOR (QUOTE (!? ! !@))) (MBINDR (CADR VARPAT) (CDDR VARPAT) EXP MV))
			 ((EQ ACTOR (QUOTE !/,))
			  ((LAMBDA(VAR VALSPEC)
			    (COND
			     (VALSPEC
			      ((LAMBDA (VAL) (COND ((EQUAL VAL EXP) (MBINDV VAR EXP MV))))
			       ((LAMBDA (MALIST) (EVAL (CAR VALSPEC))) (CDR MV))))
			     (((LAMBDA(VAL)
				(COND ((EQ VAL (QUOTE *UNASSIGNED)) (MSET VAR EXP (CDR MV)))
				      ((EQUAL VAL EXP))))
			       ((LAMBDA (MALIST) (!/,1 VAR)) (CDR MV))))))
			   (CADR VARPAT)
			   (CDDR VARPAT)))
			 ((EQ ACTOR (QUOTE !!)) NIL)
			 ((ATOM EXP) NIL)
			 ((MATCH2 ACTOR (CAR EXP) MV) (MATCH2 (CDR VARPAT) (CDR EXP) MV))))
		  (CAR VARPAT)))))
 	 EXPR)

(DEFPROP TRYBIND
	 (LAMBDA(VARSPEC PAT VALISTV PALISTV VARSALLOWED)
	  ((LAMBDA(VAR RS VARS)
	    (COND
	     (VARS
	      (COND
	       ((OR VARSALLOWED (NOT (HASMUSTASSIGNS VARS)))
		(COND ((HASVARS VARS) (MBINDV VAR (QUOTE *UNASSIGNED) VALISTV))
		      ((OR (NOT VAR) (MBINDR VAR RS (VARSUBST PAT (CDR PALISTV)) VALISTV)))))))
	     (T (MBINDR VAR RS PAT VALISTV))))
	   (CAR VARSPEC)
	   (CDR VARSPEC)
	   (FINDVARS PAT PALISTV)))
 	 EXPR)

(DEFPROP MUSTBIND
	 (LAMBDA(VARSPEC PAT VALISTV PALISTV)
	  ((LAMBDA(VAR RS VARS)
	    (COND (VARS
		   (COND ((HASVARS VARS) NIL)
			 (T (OR (NOT VAR) (MBINDR VAR RS (VARSUBST PAT (CDR PALISTV)) VALISTV)))))
		  (T (MBINDR VAR RS PAT VALISTV))))
	   (CAR VARSPEC)
	   (CDR VARSPEC)
	   (FINDVARS PAT PALISTV)))
 	 EXPR)

(DEFPROP TRYASSIGN
	 (LAMBDA(VAR PAT MALIST PALISTV VARSALLOWED)
	  ((LAMBDA(VARS)
	    (COND
	     (VARS
	      (COND
	       ((OR VARSALLOWED (NOT (HASMUSTASSIGNS VARS)))
		(COND ((HASVARS VARS)) (T (MSET VAR (VARSUBST PAT (CDR PALISTV)) MALIST))))))
	     (T (MSET VAR PAT MALIST) T)))
	   (FINDVARS PAT PALISTV)))
 	 EXPR)

(DEFPROP MUSTNOTASSIGN
	 (LAMBDA(VAR PAT VALISTV PALISTV)
	  ((LAMBDA(VARS)
	    (COND
	     (VARS (COND ((HASVARS VARS) (OR (NOT VAR) (MBIND VAR (VARSUBST PAT (CDR PALISTV)) VALISTV)))))))
	   (FINDVARS PAT PALISTV)))
 	 EXPR)

(DEFPROP FINDVARS
	 (LAMBDA(PAT MALISTV)
	  (COND ((ATOM PAT) NIL)
		(((LAMBDA(CAR)
		   (COND
		    ((EQ CAR (QUOTE !/,))
		     ((LAMBDA(VAR VALSPEC)
		       (COND ((OR (NULL VALSPEC) NOBIND) (GETSPEC (QUOTE !/,) VAR (CDR MALISTV)))
			     ((MBINDV VAR ((LAMBDA (MALIST) (EVAL (CAR VALSPEC))) (CDR MALISTV)) MALISTV)
			      (LIST (QUOTE NIL)))))
		      (CADR PAT)
		      (CDDR PAT)))
		    ((ACTOR CAR)
		     (COND (NOBIND (GETSPEC CAR (CADR PAT) (CDR MALISTV)))
			   ((MBINDV (CADR PAT) (QUOTE *UNASSIGNED) MALISTV) (LIST CAR))))
		    ((NCONC (FINDVARS CAR MALISTV) (FINDVARS (CDR PAT) MALISTV)))))
		  (CAR PAT)))))
 	 EXPR)

(DEFPROP HASMUSTASSIGNS
	 (LAMBDA (VARS) (DO V VARS (CDR V) (NULL V) (AND (MEMQ (CAR V) (QUOTE (! !@))) (RETURN T))))
 	 EXPR)

(DEFPROP HASVARS (LAMBDA (VARS) (DO V VARS (CDR V) (NULL V) (AND (CAR V) (RETURN T)))) EXPR)

(DEFPROP VARSUBST
	 (LAMBDA(PAT MALIST)
	  (COND ((ATOM PAT) PAT)
		((ACTOR (CAR PAT)) (ACTORSUBST PAT MALIST))
		((CONS (VARSUBST (CAR PAT) MALIST) (VARSUBST (CDR PAT) MALIST)))))
 	 EXPR)

(DEFPROP ACTOR (LAMBDA (ATOM) (MEMQ ATOM (QUOTE (! !? !@ !! !/,)))) EXPR)

(DEFPROP ACTORSUBST
	 (LAMBDA(PAT MALIST)
	  ((LAMBDA (VAR) ((LAMBDA (VAL) (COND ((EQ VAL (QUOTE *UNASSIGNED)) PAT) (VAL))) (!/,1 VAR)))
	   (CADR PAT)))
 	 EXPR)

(DEFPROP GETSPEC
	 (LAMBDA(ACTOR VAR MALIST)
	  (COND ((EQ (!/,1 VAR) (QUOTE *UNASSIGNED))
		 (COND (NOBIND (CERR UNASSIGNED VARIABLE IN INSTANCE)) ((LIST ACTOR))))
		((LIST NIL))))
 	 EXPR)

(DEFPROP MBIND
	 (LAMBDA(VAR VAL ALISTV)
	  (COND (NOBIND (MSET VAR VAL (CDR ALISTV))) ((RPLACD ALISTV (CONS (LIST VAR VAL) (CDR ALISTV))))))
 	 EXPR)

(DEFPROP MBINDV
	 (LAMBDA(VAR VAL ALISTV)
	  (COND ((NOT VAR))
		(NOBIND (MSET VAR VAL (CDR ALISTV)))
		((RPLACD ALISTV (CONS (LIST VAR VAL) (CDR ALISTV))))))
 	 EXPR)

(DECLARE (UNSPECIAL NOBIND))

(DEFPROP MBINDR
	 (LAMBDA(VAR RESTRICTIONS VAL ALISTV)
	  (OR (NOT VAR)
	      (AND (MBIND VAR VAL ALISTV)
		   (OR (NOT RESTRICTIONS) ((LAMBDA (MALIST) (APPLY (QUOTE AND) RESTRICTIONS)) (CDR ALISTV))))))
 	 EXPR)

(DEFPROP !/, (LAMBDA (L) (!/,1 (CAR L))) FEXPR)

(DEFPROP !/,1
	 (LAMBDA (VAR/ ) ((LAMBDA (PAIR) (COND (PAIR (CADR PAIR)) ((EVAL VAR/ )))) (ASSQ VAR/  MALIST)))
 	 EXPR)

(DEFPROP MSET
	 (LAMBDA(VAR VAL MALIST)
	  ((LAMBDA (PAIR) (PROG NIL (COND (PAIR (RPLACA (CDR PAIR) VAL) VAL) ((SET VAR VAL))) (RETURN T)))
	   (ASSQ VAR MALIST)))
 	 EXPR)

(DECLARE (UNSPECIAL MALIST))